home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / FPCDOCS.LZH / META86.SEQ < prev    next >
Text File  |  1988-09-19  |  19KB  |  577 lines
  1. \ META86.SEQ    The META compiler Source for F-PC.
  2. \  F-PC : Forth-83 with separated heads, handles, and sequential files.
  3. \  Meta compiler.  Loaded by F-PC to produce KERNEL.COM.
  4.  
  5. \ *************************************************************
  6. \ ***      ORIGINALLY   Based on F83 version 2.1.0 by       ***
  7. \ ***                                                       ***
  8. \ ***    Henry Laxen         and    Michael Perry           ***
  9. \ ***    1259 Cornell Avenue        1125 Bancroft Way       ***
  10. \ ***    Berkeley, California       Berkeley, California    ***
  11. \ ***    94706                      94702                   ***
  12. \ ***                                                       ***
  13. \ *************************************************************
  14. \     Heads separation by:     J. D. Hopper
  15. \                              P.O. Box 2782
  16. \                              Stanford, Ca.  94305
  17.  
  18. \     Handles and
  19. \     sequential files by:      Tom Zimmer          Hm  (408) 263-8859
  20. \                               292 Falcato Drive   Wk  (408) 432-4643
  21. \                               Milpitas, Ca. 95035
  22.  
  23. \     Direct Threaded Code
  24. \     conversion by:            Bob Smith and Tom Zimmer
  25. \
  26. \               Contact:        Tom Zimmer          Hm  (408) 263-8859
  27. \                               292 Falcato Drive   Wk  (408) 432-4643
  28. \                               Milpitas, Ca. 95035
  29.  
  30. DECIMAL
  31.  
  32. 0COMPILER
  33.  
  34. : ZSAVE         ( Addr len | filename -- ) \ Save code from external segment.
  35.                 seqhandle+ !HCB
  36.                 seqhandle+ HDELETE   DROP
  37.                 seqhandle+ HCREATE   ABORT" Save Create ERR!"
  38.                 seqhandle+ HWRITE 0= ABORT" Save Write  ERR!"
  39.                 seqhandle+ HCLOSE    ABORT" Save Close  ERR!" ;
  40.  
  41. WARNING OFF
  42. ONLY FORTH ALSO DEFINITIONS
  43.  
  44. 15 TABSIZE !    \ WIDER TABS
  45. 78 RMARGIN !    \ WIDER RIGHT MARGIN
  46.  0 LMARGIN !    \ LEFT MARGIN TO LEFT EDGE
  47. ?DARK           \ CLEAR SCREEN AND CLEAR #LINE
  48.  
  49. : .TITLE        CR
  50.                 ." Meta Compiled Direct Threaded Forth       "
  51.                 .DATE TAB .TIME
  52.                 CR CR ;
  53.  
  54. ONLY FORTH ALSO VOCABULARY META META ALSO META DEFINITIONS
  55.  
  56. VARIABLE SEG-Y
  57. VARIABLE SEG-X
  58.  
  59. COMMENT:
  60.           The following constant controls how many threads will be created
  61.         in the target KERNEL.COM. The constant #TTHREADS MUST BE a binary
  62.         multiple of two (2) for the KERNEL.COM to function. Any binary
  63.         multiple of two between and including 2 and 128 is acceptable.
  64.  
  65.           Higher values of #TTHREADS produces a faster compiler, but
  66.         costs more memory. i.e. from 32 to 64 threads costs 512 bytes
  67.         of code space and increases compile performance by 10%.
  68.         Increasing the number of threads from 64 to 128 costs 1024 bytes
  69.         of code space, and increases compile performance by only 4.5%.
  70. COMMENT;
  71.  
  72.  64 CONSTANT #TTHREADS
  73.  
  74. : MEMCHK ABORT" Insufficient Memory" ;
  75.  
  76. : DOSVER 0 $030 BDOS $0FF AND ;
  77.  
  78. : DOSCHK  DOSVER 2 < ABORT" Must have DOS >=2" ;
  79.  
  80.  DOSCHK
  81.  
  82. $0800 CONSTANT HEADSEGS   \ 800 hex is 32k decimal bytes
  83. $0800 CONSTANT LISTSEGS
  84.                         \ Create and erase the buffers
  85. HEADSEGS ALLOC 8 = MEMCHK NIP DUP SEG-Y ! 0 HEADSEGS $010 * 0 LFILL
  86. LISTSEGS ALLOC 8 = MEMCHK NIP DUP SEG-X ! 0 LISTSEGS $010 * 0 LFILL
  87.  
  88. : NYTH ( cfa -- ythread) 512 / 2* ;
  89.  
  90. : ?NEWPAGE      ( --- )
  91.                 PRINTING @ 0= IF EXIT THEN
  92.                 #LINE @ 60 >
  93.                 IF      CR
  94.                         12 SP@ 1 TYPE DROP #LINE OFF
  95.                         CR .TITLE
  96.                 THEN    ;
  97.  
  98. VARIABLE LABELS         LABELS OFF      \ DEFAULT TO NOT DISPLAY MAP
  99.  
  100. : ?LABELS       ( --- )
  101.                 CR CR ." Do you want LABELS printed Y/N [N]? "
  102.                 KEY BL OR ASCII y = DUP LABELS !
  103.                 IF      ." Y"
  104.                 ELSE    ." N"   THEN CR .TITLE TIME-RESET ;
  105.  
  106. ?LABELS
  107.  
  108. 3 CONSTANT BODY_SIZE                    \ SIZE OF BODY FIELD IN BYTES
  109.  
  110. : >BODY-T       ( A1 --- A2 )           \ Move to body of target
  111.                 BODY_SIZE + ;
  112.  
  113. VARIABLE DP-T
  114.  
  115. : [FORTH]        FORTH   ; IMMEDIATE
  116.  
  117. : [META]         META    ; IMMEDIATE
  118.  
  119. : [ASSEMBLER]    ASSEMBLER    ; IMMEDIATE
  120.  
  121. : SWITCH   ( -- )
  122.    NOOP    ( Context )   NOOP ( Current )
  123.    DOES>   @ XSEG @ + DUP 0 @L CONTEXT @   SWAP CONTEXT !   OVER 0 !L
  124.                       DUP 2 @L CURRENT @   SWAP CURRENT !   SWAP 2 !L ;
  125.    SWITCH  ( Redefine itself )
  126.  
  127. 0 CONSTANT TARGET-ORIGIN
  128. : THERE   ( taddr -- addr )   TARGET-ORIGIN +   ;
  129. : C@-T    ( taddr -- char )   THERE C@ ;
  130. : @-T     ( taddr -- n )      THERE @  ;
  131. : C!-T    ( char taddr -- )   THERE C! ;
  132. : !-T     ( n taddr -- )      THERE !  ;
  133. : HERE-T  ( -- taddr )   DP-T @   ;
  134. : ALLOT-T ( n -- )       DP-T +!   ;
  135. : C,-T    ( char -- )   HERE-T C!-T   1 ALLOT-T   ;
  136. : ,-T     ( n -- )      HERE-T  !-T   2 ALLOT-T   ;
  137. : S,-T    ( addr len -- )
  138.    0 ?DO   COUNT C,-T   LOOP   DROP   ;
  139.  
  140. : XS:     ( taddr -- taddr tseg ) SEG-X @ SWAP ;
  141. VARIABLE DP-X           0 DP-X !
  142. VARIABLE DPSEG-X        SEG-X @ DPSEG-X !
  143.  
  144. : PARAGRAPH-X   ( N1 --- SEG-DELTA ) 15 + U16/ ;
  145. : >XREL         ( SEG OFFSET --- OFFSET )     \ RELATIVE TO SEG-X
  146.                 SWAP SEG-X @ - 16 * + ;
  147.  
  148. : C@-X    ( taddr -- char )   XS: C@L ;
  149. : @-X     ( taddr -- n )      XS: @L  ;
  150. : C!-X    ( char taddr -- )   XS: C!L ;
  151. : !-X     ( n taddr -- )      XS: !L  ;
  152. : HERE-X  ( -- XDPSEG taddr )   DPSEG-X @ DP-X @   ;
  153. : ALLOT-X ( n -- )       DP-X +!   ;
  154. : C,-X    ( char -- )   HERE-X C!L   1 ALLOT-X   ;
  155. : ,-X     ( n -- )      HERE-X  !L   2 ALLOT-X   ;
  156. : S,-X    ( addr len -- )
  157.         0 ?DO   COUNT C,-X   LOOP   DROP   ;
  158.  
  159. : ALIGN-X       ( --- )
  160.                 HERE-X NIP 1 AND IF 0 C,-X THEN ;
  161.  
  162. : YS:   SEG-Y @ SWAP ;
  163. VARIABLE DP-Y    256 DP-Y !
  164. : C@-Y    ( yaddr -- char )   YS: C@L  ;
  165. : @-Y     ( yaddr -- n )      YS: @L  ;
  166. : C!-Y    ( char yaddr -- )   YS: C!L ;
  167. : !-Y     ( n yaddr -- )      YS: !L  ;
  168. : HERE-Y  ( -- yaddr )        DP-Y @ ;
  169. : ALLOT-Y ( n -- )    DP-Y +! ;
  170. : C,-Y    ( char -- ) HERE-Y C!-Y  1 ALLOT-Y  ;
  171. : ,-Y     ( n -- )    HERE-Y  !-Y  2 ALLOT-Y  ;
  172. : S,-Y    ( addr len )  0 ?DO COUNT C,-Y  LOOP  DROP  ;
  173. : CSET-Y  ( byte yaddr -- )  TUCK C@-Y OR SWAP C!-Y ;
  174.  
  175. : SVXSEG        ( - xstart )
  176.                 SEG-X @ 0 ?CS: HERE-T  DUP >R THERE
  177.                 HERE-X PARAGRAPH-X + SEG-X @ - 16 *
  178.                 CR ." LIST size = " DUP U.
  179.                 CMOVEL R> ;
  180.  
  181. : SVYSEG        ( - ystart )
  182.                 SEG-Y @ 0 ?CS: HERE-T  DUP >R THERE HERE-Y
  183.                 CR ." HEAD size = " DUP U.
  184.                 CMOVEL R> ;
  185.  
  186. : CNHASH ( CFA-YA )  $0FE00 AND FLIP ;
  187.  
  188. VARIABLE UNRESOLVED
  189.  
  190. : .UNRESOLVEPAUSE   ( --- )
  191.                 UNRESOLVED @
  192.                 IF      BEEP >NORM
  193.                         CR ." There were UNRESOLVED references,"
  194.                         CR >REV ." press a key to acknoledge." KEY DROP >NORM
  195.                         CR
  196.                 ELSE    >NORM ."  **** ALL REFERENCES RESOLVED **** "
  197.                 THEN    ;
  198.  
  199. VOCABULARY TARGET
  200. VOCABULARY TRANSITION
  201. VOCABULARY FORWARD
  202. VOCABULARY USER
  203.  
  204. ONLY DEFINITIONS FORTH ALSO META ALSO
  205.  
  206. : META          META ;
  207. : TARGET        TARGET ;
  208. : TRANSITION    TRANSITION ;
  209. : FORWARD       FORWARD ;
  210. : USER          USER   ;
  211. : ASSEMBLER     ASSEMBLER ;
  212.  
  213. ONLY FORTH ALSO META ALSO DEFINITIONS
  214.  
  215. : X?>MARK       ( -- f addr )   TRUE   HERE-X NIP 0 ,-X   ;
  216. : X?>RESOLVE    ( f addr -- )   HERE-X -ROT SWAP !L   ?CONDITION  ;
  217. : X?<MARK       ( -- f addr )   TRUE   HERE-X NIP ;
  218. : X?<RESOLVE    ( f addr -- )   ,-X   ?CONDITION   ;
  219.  
  220. : AM?>MARK      ( -- f addr )   TRUE   HERE-T   0 C,-T   ;
  221. : AM?>RESOLVE   ( f addr -- )   HERE-T OVER 1+ - SWAP C!-T   ?CONDITION   ;
  222. : AM?<MARK      ( -- f addr )   TRUE   HERE-T   ;
  223. : AM?<RESOLVE   ( f addr -- )   HERE-T 1+ - C,-T   ?CONDITION   ;
  224.  
  225. '   C,-T        ASSEMBLER IS  C,
  226. '    ,-T        ASSEMBLER IS   ,
  227. ' HERE-T        ASSEMBLER IS HERE
  228. ' AM?>MARK      ASSEMBLER IS ?>MARK
  229. ' AM?>RESOLVE   ASSEMBLER IS ?>RESOLVE
  230. ' AM?<MARK      ASSEMBLER IS ?<MARK
  231. ' AM?<RESOLVE   ASSEMBLER IS ?<RESOLVE
  232.  
  233. ONLY FORTH ALSO META ALSO DEFINITIONS
  234.  
  235. : LABEL         ( | NAME -- )
  236.                 0 ['] DROP A;!
  237.                 ['] RUN-A; IS RUN
  238.                 ASSEMBLER DEFINITIONS
  239.                 >IN @ >R HERE-T CONSTANT
  240.                 LABELS @
  241.                 IF      R> >IN !
  242.                         BL WORD DUP C@ 5 + ?LINE
  243.                         HERE-T H.
  244.                         COUNT TYPE TAB
  245.                         ?NEWPAGE
  246.                 ELSE    r>drop  THEN !CSP ;
  247.  
  248. : XLABEL        ( | NAME -- )
  249.                 0 ['] DROP A;!
  250.                 ['] RUN-A; IS RUN
  251.                 ASSEMBLER DEFINITIONS
  252.                 >IN @ >R HERE-X >XREL CONSTANT
  253.                 LABELS @
  254.                 IF      R> >IN !
  255.                         BL WORD DUP C@ 5 + ?LINE
  256.                         HERE-T H.
  257.                         COUNT TYPE TAB
  258.                         ?NEWPAGE
  259.                 ELSE    r>drop  THEN !CSP ;
  260.  
  261. : MAKE-CODE     ( PFA -- ) @ ,-X   ;                    \ Absolute address
  262. : MAKE-CODE-REL ( PFA -- ) @ HERE-T 2+ - ,-T   ;        \ Relative offset
  263.  
  264. : IN-TARGET     ( -- )          ONLY TARGET DEFINITIONS   ;
  265. : IN-TRANSITION ( -- )          ONLY FORWARD ALSO TARGET DEFINITIONS
  266.                                 ALSO TRANSITION   ;
  267. : IN-META       ( -- )          ONLY FORTH ALSO META DEFINITIONS ALSO   ;
  268. : IN-FORWARD    ( -- )          FORWARD DEFINITIONS   ;
  269. : LINK-BACKWARDS     ( PFA -- ) HERE-X >XREL OVER @ ,-X   SWAP !   ;
  270. : LINK-BACKWARDS-REL ( PFA -- ) HERE-T OVER @ ,-T   SWAP !   ;
  271. : RESOLVED?     ( pfa -- f )    2+ @   ;
  272.  
  273. : FORWARD-CODE  ( pfa -- )      DUP RESOLVED?
  274.                                 IF      MAKE-CODE
  275.                                 ELSE    LINK-BACKWARDS  THEN ;
  276.  
  277. : FORWARD-CODE-REL ( pfa -- )   DUP RESOLVED?
  278.                                 IF      MAKE-CODE-REL
  279.                                 ELSE    LINK-BACKWARDS-REL  THEN ;
  280.  
  281. : FORWARD:      ( -- )
  282.                 SWITCH   FORWARD DEFINITIONS
  283.                 CREATE SWITCH  0 , 0 , DOES>   FORWARD-CODE   ;
  284.  
  285. : FORWARD_REL:  ( -- )
  286.                 SWITCH   FORWARD DEFINITIONS
  287.                 CREATE SWITCH  0 , 0 , DOES>   FORWARD-CODE-REL ;
  288.  
  289. VARIABLE WIDTH  31 WIDTH !
  290. VARIABLE LAST-T
  291. VARIABLE CONTEXT-T
  292. VARIABLE CURRENT-T
  293.  
  294. : HASH          ( str-addr voc-addr -- thread )
  295.                 SWAP
  296.                 DUP C@ SWAP 1+ DUP C@ 2* SWAP 1+ C@ + 2* +
  297.                 #TTHREADS 1- AND 2* +   ;
  298.  
  299. : HEADER        ( -- )
  300.                 BL WORD C@ 1+ WIDTH @ MIN   ?DUP
  301.         IF      ( HERE-Y 2- )   ( for ylink at end)
  302.                 ALIGN
  303.                 HERE-Y 2- @-Y CNHASH HERE-T CNHASH <> IF
  304.                 HERE-Y HERE-T CNHASH !-Y THEN  ( >NAME hash entry )
  305.                 LOADLINE @ ,-Y
  306.                 HERE CURRENT-T @ HASH DUP @-T ,-Y ( link )
  307.                 HERE-Y 2- SWAP !-T      ( point voc thread to link field )
  308.                 HERE-Y HERE ROT S,-Y   ALIGN   DUP LAST-T !
  309.                 128 SWAP CSET-Y   128 HERE-Y 1- CSET-Y
  310.                 HERE-T ,-Y              ( cfa ptr )
  311.                 HERE-Y HERE-T CNHASH 2+ !-Y     ( stopper >NAME hash entry )
  312.         THEN    ;
  313.  
  314. : TARGET-CREATE ( -- )
  315.                 >IN @ HEADER DUP >IN !
  316.                 LABELS @
  317.                 IF      BL WORD DUP C@ 5 + ?LINE
  318.                         HERE-T H.
  319.                         COUNT TYPE TAB ?NEWPAGE
  320.                 THEN    >IN !
  321.                 IN-TARGET CREATE IN-META  HERE-T , TRUE ,
  322.                 DOES>   MAKE-CODE   ;
  323.  
  324. : RECREATE      ( -- )  >IN @   TARGET-CREATE   >IN !   ;
  325.  
  326.  
  327. FORTH DEFINITIONS
  328.  
  329. : CODE          ( NAME --- )
  330.                 0 ['] DROP A;!
  331.                 ['] RUN-A; IS RUN
  332.                 TARGET-CREATE ASSEMBLER !CSP ;
  333.  
  334. : INLINE        ( --- )
  335.                 0 ['] DROP A;!
  336.                 ['] RUN-A; IS RUN
  337.                 ASSEMBLER !CSP HERE-T ,-X ;
  338.  
  339.  
  340. ASSEMBLER ALSO DEFINITIONS
  341.  
  342. : END-CODE      ['] <RUN> IS RUN
  343.                 A; IN-META ?CSP ;
  344.  
  345. : END-INLINE    ['] <RUN> IS RUN
  346.                 A; IN-META ?CSP ;
  347.  
  348. : C;            ['] <RUN> IS RUN
  349.                 A; IN-META ?CSP ;
  350.  
  351. META IN-META
  352.  
  353. : 'T            ( -- cfa )
  354.                 CONTEXT @   TARGET DEFINED   ROT CONTEXT !
  355.                 0= ?MISSING   ;
  356.  
  357. : [TARGET]      ( -- )          'T X, ;   IMMEDIATE
  358.  
  359. : 'F            ( -- cfa )
  360.                 CONTEXT @   FORWARD DEFINED   ROT CONTEXT !
  361.                 0= ?MISSING   ;
  362.  
  363. : [FORWARD]     ( -- )  'F X, ;   IMMEDIATE
  364.  
  365. : T:            ( -- )
  366.                 SWITCH  TRANSITION DEFINITIONS
  367.                 CREATE  XHERE PARAGRAPH + DUP XDPSEG ! XSEG @ - , XDP OFF
  368.                 SWITCH  ]
  369.                 DOES>   @ XSEG @ + >R 0 >R ;
  370.  
  371. : T;            ( -- )
  372.                 SWITCH   TRANSITION DEFINITIONS   [COMPILE] ;    SWITCH   ;
  373.                 IMMEDIATE
  374.  
  375. : DIGIT?        ( CHAR -- F )   BASE @ DIGIT NIP   ;
  376.  
  377. : PUNCT?        ( CHAR -- F )
  378.                 ASCII . OVER = SWAP   ASCII - OVER = SWAP
  379.                 ASCII / OVER = SWAP   DROP OR OR ;
  380.  
  381. : NUMERIC?      ( ADDR LEN -- F )
  382.                 BASE @ >R
  383.                 OVER C@ ASCII $ =
  384.                 IF      1- SWAP 1+ SWAP HEX
  385.                 THEN    DUP 1 =
  386.                 IF      DROP C@ DIGIT?
  387.                 ELSE    1 -ROT   0 ?DO   DUP C@   DUP DIGIT? SWAP PUNCT? OR
  388.                         ROT AND SWAP 1+   LOOP   DROP
  389.                 THEN    R> BASE ! ;
  390.  
  391. T: (    [COMPILE] (     T;
  392. T: (    [COMPILE] (     T;
  393. T: \    [COMPILE] \     T;
  394.  
  395. : STRING,-T     ( -- )
  396.                 ASCII " PARSE  DUP C,-T  S,-T  ALIGN  ;
  397.  
  398. : STRING,-X     ( -- )
  399.                 ASCII " PARSE  DUP C,-X  S,-X  ALIGN-X ;
  400.  
  401.                 FORWARD: <(.")>
  402. T: ."           [FORWARD]  <(.")>  STRING,-X   T;
  403.  
  404.                 FORWARD: <(")>
  405. T: "            [FORWARD] <(")>    HERE-T ,-X STRING,-T   T;
  406.  
  407.                 FORWARD: <(ABORT")>
  408. T: ABORT"       [FORWARD] <(ABORT")> STRING,-X   T;
  409.  
  410.                 FORWARD_REL: <VARIABLE>
  411. : CREATE        RECREATE
  412.                 232 C,-T
  413.                 [FORWARD] <VARIABLE>   HERE-T CONSTANT   ;
  414.  
  415. : VARIABLE      ( | name -- ) CREATE   0 ,-T   ;
  416.  
  417.                 FORWARD_REL: <DEFER>
  418. : DEFER         ( -- )
  419.                 TARGET-CREATE
  420.                 232 C,-T                        \ CALL instruction
  421.                 [FORWARD] <DEFER>   0 ,-T   ;
  422.  
  423. FORTH
  424.  
  425. VARIABLE #USER-T
  426.  
  427. META ALSO USER DEFINITIONS
  428.  
  429. : ALLOT         ( n -- )
  430.                 #USER-T +!   ;
  431.  
  432.                 FORWARD_REL: <USER-VARIABLE>
  433. : VARIABLE      ( -- )
  434.                 SWITCH   RECREATE
  435.                 232 C,-T
  436.                 [FORWARD] <USER-VARIABLE>   #USER-T @
  437.                 DUP ,-T   2 ALLOT   META DEFINITIONS   CONSTANT   SWITCH   ;
  438.  
  439.                 FORWARD_REL: <USER-DEFER>
  440. : DEFER         ( -- )
  441.                 SWITCH   TARGET-CREATE
  442.                 232 C,-T
  443.                 [FORWARD] <USER-DEFER>   SWITCH
  444.                 #USER-T @ ,-T   2 ALLOT   ;
  445.  
  446. ONLY FORTH ALSO META ALSO DEFINITIONS
  447.  
  448. FORTH VARIABLE VOC-LINK-T META
  449.  
  450.                 FORWARD_REL: <VOCABULARY>
  451. : VOCABULARY    ( -- )
  452.                 RECREATE
  453.                 232 C,-T                \ CALL instruction to DOVOC
  454.                 [FORWARD] <VOCABULARY>
  455.                 HERE-T   #TTHREADS 0 DO  0 ,-T  LOOP
  456.                 HERE-T VOC-LINK-T @ ,-T   VOC-LINK-T !
  457.                 CONSTANT DOES> @ CONTEXT-T !   ;
  458.  
  459. : IMMEDIATE     ( -- )
  460.                 WIDTH @
  461.                 IF ( Headers present? )
  462.                 64 ( Precedence Bit )   LAST-T @   CSET-Y   THEN   ;
  463.  
  464. FORWARD: <(;USES)>
  465.  
  466. FORTH
  467.  
  468. VARIABLE STATE-T
  469.  
  470. META
  471.  
  472. T: ;USES        ( -- )
  473.                 [FORWARD] <(;USES)>   IN-META ASSEMBLER
  474.                 !CSP   STATE-T OFF   T;
  475.  
  476. T: [COMPILE]    'T EXECUTE    T;
  477.  
  478.                 FORWARD: <(IS)>
  479. T: IS           [FORWARD] <(IS)>    T;
  480. :  IS           'T  ( CR HERE COUNT TYPE TAB OVER H. )
  481.                 >BODY @ >BODY-T !-T ;
  482.  
  483. T: ALIGN   T;
  484.  
  485. T: EVEN    T;
  486.  
  487. : .SYMBOLS      ( -- )
  488.                 TARGET   CONTEXT @ HERE #TTHREADS 2* CMOVE  CR
  489.                 BEGIN   HERE 4 LARGEST  DUP
  490.                 WHILE   DUP L>NAME  DUP Y@ 31 AND 2+ ?LINE
  491.                         ."  /  "  DUP .ID
  492.                         NAME> >BODY @ U.
  493.                         Y@ SWAP !
  494.                         KEY? IF   EXIT   THEN
  495.                 REPEAT  2DROP   IN-META   ;
  496.  
  497. : .UNRESOLVED   ( -- )
  498.                 UNRESOLVED OFF
  499.                 FORWARD CONTEXT @ HERE #THREADS 2* CMOVE
  500.                 BEGIN   HERE #THREADS LARGEST   DUP
  501.                 WHILE   ?CR DUP L>NAME NAME> >BODY
  502.                         RESOLVED? 0=
  503.                         IF      >ATTRIB4 DUP L>NAME .ID >NORM UNRESOLVED ON
  504.                         THEN
  505.                         Y@  SWAP !
  506.                 REPEAT  2DROP .UNRESOLVEPAUSE IN-META ;
  507.  
  508. : FIND-UNRESOLVED ( -- cfa f )  'F    DUP  >BODY RESOLVED?     ;
  509.  
  510. DECIMAL
  511.  
  512. : RESOLVE       ( taddr cfa -- )
  513.                 >BODY   2DUP   TRUE OVER 2+ !   @
  514.                 BEGIN   DUP
  515.                 WHILE   2DUP @-T   -ROT SWAP
  516.                         DUP 1-  C@-T 232 =            \ IF PRECEEDED BY CALL
  517.                         IF      DUP 2+ ROT SWAP - SWAP \ SWITCH TO RELATIVE
  518.                         THEN    !-T
  519.                 REPEAT  2DROP  ! ;
  520.  
  521. : RESOLVES      ( taddr -- )
  522.                 FIND-UNRESOLVED
  523. \                #OUT @ 60 > IF CR THEN HERE COUNT TYPE SPACE
  524.                 IF      CR >NAME .ID ." Already Resolved" DROP
  525.                 ELSE    RESOLVE   THEN   ;
  526.  
  527. : :RESOLVE      ( taddr cfa -- )
  528.                 >BODY   2DUP   TRUE OVER 2+ !   @
  529.                 BEGIN   DUP
  530.                 WHILE   2DUP @-X   -ROT SWAP !-X
  531.                 REPEAT  2DROP  ! ;
  532.  
  533. : :RESOLVES     ( taddr -- )
  534.                 FIND-UNRESOLVED
  535.                 IF      CR >NAME .ID ." Already Resolved" DROP
  536.                 ELSE    :RESOLVE   THEN   ;
  537.  
  538. : H:    [COMPILE] :   ;
  539.  
  540. H: '     'T >BODY @   ;
  541. H: ,    ,-T ;
  542. H: C,  C,-T ;
  543. H: X,   ,-X ;
  544. H: XC, C,-X ;
  545.  
  546. H: HERE         HERE-T ;
  547. H: XHERE        ( HERE-X ) TRUE ABORT" Used HERE-X" ;
  548. H: ALLOT        ALLOT-T   ;
  549. H: DEFINITIONS  DEFINITIONS   CONTEXT-T @ CURRENT-T !   ;
  550.  
  551. ONLY FORTH DEFINITIONS ALSO
  552.  
  553. .( Meta Compiler Loaded )
  554.  
  555. CR .ELAPSED CR
  556.  
  557. FLOAD KERNEL1.SEQ
  558. FLOAD VIDEO.SEQ
  559. FLOAD KERNEL2.SEQ
  560. FLOAD VIDEO2.SEQ
  561. FLOAD KERNEL3.SEQ
  562. FLOAD EQUCOLON.SEQ
  563. FLOAD SAVEREST.SEQ
  564. FLOAD HANDLES.SEQ
  565. FLOAD SEQREAD.SEQ
  566. FLOAD DEFAULT.SEQ
  567. FLOAD KERNEL4.SEQ
  568.  
  569. CAPS ON
  570.  8 TABSIZE !    \ RESTORE TABS
  571. 70 RMARGIN !    \ RESTORE RIGHT MARGIN
  572. #OUT @ #LINE @  \ Save where we are on screen.
  573. ?PAGE           \ NEW PAGE
  574. PRINTING OFF    \ NO PRINTING ANY MORE
  575. 2- AT CR        \ Go back there.
  576.  
  577.